home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Src / read.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-05-17  |  6.2 KB  |  260 lines
  1. /*
  2.  * r e a d  . c                -- reading stuff
  3.  *
  4.  * Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  5.  * 
  6.  *
  7.  * Permission to use, copy, and/or distribute this software and its
  8.  * documentation for any purpose and without fee is hereby granted, provided
  9.  * that both the above copyright notice and this permission notice appear in
  10.  * all copies and derived works.  Fees for distribution or use of this
  11.  * software or derived works may only be charged with express written
  12.  * permission of the copyright holder.  
  13.  * This software is provided ``as is'' without express or implied warranty.
  14.  *
  15.  * This software is a derivative work of other copyrighted softwares; the
  16.  * copyright notices of these softwares are placed in the file COPYRIGHTS
  17.  *
  18.  *           Author: Erick Gallesio [eg@unice.fr]
  19.  *    Creation date: ??-Oct-1993 ??:?? 
  20.  * Last file update: 17-May-1996 18:39
  21.  *
  22.  */
  23.  
  24. #include <ctype.h>
  25. #include "stk.h"
  26.  
  27. static SCM lreadr(FILE *f, int case_significant);
  28.  
  29.  
  30. static int flush_ws(FILE *f, char *message)
  31. {
  32.   int c, commentp=0;
  33.  
  34.   c = Getc(f);
  35.   for ( ; ; ) {
  36.     switch (c) {
  37.       case EOF:  if (message) Err(message,NIL); else return(c);
  38.       case ';':  do 
  39.            c = Getc(f); 
  40.          while (c != '\n' && c != EOF);
  41.          continue;
  42.       case '\n': STk_line_counter += 1; break;
  43.       default:   if (!isspace(c)) return(c);
  44.     }
  45.     c = Getc(f);
  46.   }
  47. }
  48.  
  49. static SCM lreadlist(FILE *f, char delim, int case_significant)
  50. /* Read a list ended by the `delim' char */
  51. {
  52.   int c;
  53.   SCM tmp;
  54.   
  55.   c = flush_ws(f, "end of file inside list");
  56.   if (c == delim) return(NIL);
  57.  
  58.   /* Read the car */
  59.   Ungetc(c, f);
  60.   tmp = lreadr(f, case_significant);
  61.   
  62.   /* Read the cdr */
  63.   if (EQ(tmp, Sym_dot)) {
  64.     tmp = lreadr(f, case_significant);
  65.     c = flush_ws(f, "end of file inside list");
  66.     if (c != delim) Err("missing close paren", NIL);
  67.     return(tmp);
  68.   }
  69.   return(Cons(tmp, lreadlist(f, delim, case_significant)));
  70. }
  71.  
  72. static void lreadword(FILE *f, int c, int case_significant) 
  73. /* read an item whose 1st char is in c */
  74. { 
  75.   register int j = 0;
  76.   int allchars   = 0;
  77.  
  78.   for( ; ; ) {
  79.     allchars  ^= (c == '|');
  80.     if (c != '|') 
  81.       STk_tkbuffer[j++]  = (allchars || case_significant) ? c : tolower(c);
  82.  
  83.     c = Getc(f);
  84.     if (c == EOF) break;
  85.     if (!allchars) {
  86.       if (strchr("()[]'`,;\"\n", c)) {
  87.     Ungetc(c, f);
  88.     break;
  89.       }
  90.       if (isspace(c)) break;
  91.     }
  92.     if (j >= TKBUFFERN-1) Err("read: token too large", NIL);
  93.   }
  94.  
  95.   STk_tkbuffer[j] = '\0';
  96. }
  97.  
  98. static void lreadchar(FILE *f, int c)
  99. /* read an char (or a char name) item whose 1st char is in c */
  100. { 
  101.   register int j = 0;
  102.  
  103.   for( ; ; ) {
  104.     STk_tkbuffer[j++] = c;
  105.     c = Getc(f);
  106.     if (c == EOF || isspace(c)) break;
  107.     if (strchr("()[]'`,;\"", c)) {
  108.       Ungetc(c, f);
  109.       break;
  110.     }
  111.     if (j >= TKBUFFERN-1) Err("read: token too large", NIL);
  112.   }
  113.   STk_tkbuffer[j] = '\0';
  114. }
  115.   
  116. static SCM lreadtoken(FILE *f, int c, int case_significant) 
  117. {
  118.   SCM z;
  119.  
  120.   lreadword(f, c, case_significant);
  121.   z = STk_Cstr2number(STk_tkbuffer, 10L);
  122.  
  123.   if (z == Ntruth)
  124.     /* It is not a number */
  125.     return (*STk_tkbuffer == ':') ? STk_makekey(STk_tkbuffer): Intern(STk_tkbuffer);
  126.  
  127.   /* Return the number read */
  128.   return z;
  129. }
  130.  
  131. static SCM lreadstring(FILE *f)
  132. {
  133.   int j, k ,c,n,len;
  134.   char *p, *buffer;
  135.   SCM z;
  136.  
  137.   j = 0;
  138.   len = 100;
  139.   p = buffer = must_malloc(len);
  140.  
  141.   while(((c = Getc(f)) != '"') && (c != EOF)) { 
  142.     if (c == '\\') {
  143.       c = Getc(f);
  144.       if (c == EOF) Err("eof after \\", NIL);
  145.       switch(c) {
  146.         case 'b' : c = '\b'; break;    /* Bs  */
  147.     case 'e' : c = 0x1b; break;    /* Esc */
  148.     case 'n' : c = '\n'; break;    /* Lf  */
  149.     case 'r' : c = '\r'; break;    /* Cr  */
  150.     case 't' : c = '\t'; break;    /* Tab */
  151.         case '\n': STk_line_counter += 1; continue;
  152.     case '0' : for( k=n=0 ; ; k++ ) {
  153.              c = Getc(f);
  154.              if (c == EOF) Err("eof after \\0", NIL);
  155.                  if (isdigit(c) && (c < '8') && k < 3) /* Max = 3 digits */
  156.                 n = n * 8 + c - '0';
  157.              else {
  158.                Ungetc(c, f);
  159.                break;
  160.              }
  161.            }
  162.                c = n & 0xff;
  163.       }
  164.     }
  165.     else
  166.       if (c == '\n') STk_line_counter += 1;
  167.  
  168.     if ((j + 1) >= len) {
  169.       len = len + len / 2;
  170.       buffer = must_realloc(buffer, len);
  171.       p = buffer + j;
  172.     }
  173.     j++;
  174.     *p++ = c;
  175.   }
  176.   if (c == EOF) Err("end of file while reading a string", NIL);
  177.   *p = '\0';
  178.   
  179.   z = STk_makestrg(j, buffer);
  180.   free(buffer);
  181.  
  182.   return z;
  183. }
  184.  
  185. static SCM lreadr(FILE *f, int case_significant)
  186. {
  187.   int c;
  188.  
  189.   for ( ; ; ) {
  190.     c = flush_ws(f, "end of file inside read encountered");
  191.     
  192.     switch (c) {
  193.       case '(':
  194.         return(lreadlist(f, ')', case_significant));
  195.       case '[':
  196.     return(lreadlist(f, ']', case_significant));
  197.       case ')':
  198.       case ']':
  199.     fprintf(STk_stderr, "\nunexpected close parenthesis");
  200.     if (STk_current_filename != UNBOUND)    
  201.       fprintf(STk_stderr, " at line %d in file %s", 
  202.                     STk_line_counter, CHARS(STk_current_filename));
  203.     fprintf(STk_stderr, "\n");
  204.     break;
  205.       case '\'':
  206.     return LIST2(Sym_quote, lreadr(f, case_significant));
  207.       case '`':
  208.     return LIST2(Sym_quasiquote, lreadr(f, case_significant));
  209.       case '#':
  210.     switch(c=Getc(f)) {
  211.       case 't':
  212.           case 'T':  return Truth;
  213.       case 'f':
  214.       case 'F':  return Ntruth;
  215.        case '\\': lreadchar(f, Getc(f));
  216.                  return STk_makechar(STk_string2char(STk_tkbuffer));
  217.       case '(' : { 
  218.                    SCM l = lreadlist(f, ')', case_significant);
  219.                return STk_vector(l, STk_llength(l));
  220.                }
  221.       case '!' : while ((c=Getc(f)) != '\n')
  222.                    if (c == EOF) Err("eof encountered in a #! notation", NIL);
  223.              Ungetc(c, f);
  224.                  continue;
  225.       case 'p':
  226.       case 'P': lreadword(f, Getc(f), TRUE);
  227.                 return STk_address2object(STk_tkbuffer);
  228.       case '.': return STk_eval(lreadr(f, case_significant), NIL);
  229.       default:  Ungetc(c, f); return lreadtoken(f, '#', FALSE);
  230.     }
  231.       case ',': {
  232.     SCM symb;
  233.  
  234.     c = Getc(f);
  235.     if (c == '@') 
  236.       symb = Sym_unq_splicing;
  237.     else {
  238.       symb = Sym_unquote; 
  239.       Ungetc(c, f);
  240.     }
  241.     return LIST2(symb, lreadr(f, case_significant));
  242.       }
  243.       case '"':
  244.     return lreadstring(f);
  245.       default:
  246.     return lreadtoken(f, c, case_significant);
  247.     }
  248.   }
  249. }
  250.  
  251. SCM STk_readf(FILE *f, int case_significant)
  252. {
  253.   int c;
  254.   
  255.   c = flush_ws(f, (char *) NULL);
  256.   if (c == EOF) return(STk_eof_object);
  257.   Ungetc(c, f);
  258.   return lreadr(f, case_significant);
  259. }
  260.